home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istan / ISTAN.MAC.f < prev   
Encoding:
Text File  |  1989-03-04  |  14.4 KB  |  413 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 2.3
  3. C---------------------------------------------------------
  4. C---------------------------------------------------------
  5. C    TOOLPACK/1    Release: 2.3
  6. C---------------------------------------------------------
  7.         PROGRAM ISTAN
  8.  
  9. C---------------------------------------------------------
  10. C    TOOLPACK/1    Release: 2.3
  11. C---------------------------------------------------------
  12.         COMMON/IO/IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  13.         INTEGER IODINS,IODSTS,IODSUM,IODSCR,TKIDES,TKODES
  14.  
  15.         SAVE /IO/
  16.  
  17. C---------------------------------------------------------
  18. C    TOOLPACK/1    Release: 2.3
  19. C---------------------------------------------------------
  20. C                  KEYWORD ID VARIABLES
  21.       COMMON / KEYSC   /    KAGOG,       KAIFG,       KASMTG,
  22.      *         KASSNG,      KBACKG,      KBIFG,       KBLOKG,
  23.      *         KCALLG,      KCFUNG,      KCGOG,       KCHARG,
  24.      *         KCLOSG,      KCMPXG,      KCOMNG,      KCONTG,
  25.      *         KDATAG,      KDBLEG,      KDFUNG,      KDIMNG,
  26.      *         KDOG,        KELSEG,      KELSFG,      KENDFG,
  27.      *         KENDG,       KENDIG,      KEQIVG,      KEXTLG,
  28.      *         KFORMG,      KIFUNG,      KIMPLG,      KINQRG,
  29.      *         KINSCG,      KINTEG,      KLFUNG,      KLIFG,
  30.      *         KLOGCG,      KNONEG,      KNTRYG,      KOPENG,
  31.      *         KPARAG,      KPAUSG,      KPRNTG,      KPROGG,
  32.      *         KREADG,      KREALG,      KRETNG,      KRFUNG,
  33.      *         KSAVEG,      KSFUNG,      KSTOPG,      KSUBRG,
  34.      *         KUFUNG,      KUGOG,       KWINDG,      KWRITG,
  35.      *         KXFUNG,      LASRTG,      LCMNTG,      LERRG,
  36.      *         LLINEG,      LSTMTG
  37.  
  38.         INTEGER KAGOG,KAIFG,KASMTG,KASSNG,KBACKG,KBIFG,KBLOKG,KCALLG,
  39.      +          KCFUNG,KCGOG,KCHARG,KCLOSG,KCMPXG,KCOMNG,KCONTG,KDATAG,
  40.      +          KDBLEG,KDFUNG,KDIMNG,KDOG,KELSEG,KELSFG,KENDFG,KENDG,
  41.      +          KENDIG,KEQIVG,KEXTLG,KFORMG,KIFUNG,KIMPLG,KINQRG,KINSCG,
  42.      +          KINTEG,KLFUNG,KLIFG,KLOGCG,KNONEG,KNTRYG,KOPENG,KPARAG,
  43.      +          KPAUSG,KPRNTG,KPROGG,KREADG,KREALG,KRETNG,KRFUNG,KSAVEG,
  44.      +          KSFUNG,KSTOPG,KSUNRG,KUUNG,KUGOG,KWINDG,KWRITG,KXFUNG,
  45.      +          LASRTG,LCMNTG,LERRG,LLINEG,LSTMTG
  46.         INTEGER KUFUNG,KSUBRG
  47.  
  48.         SAVE /KEYSC/
  49.  
  50. C---------------------------------------------------------
  51. C    TOOLPACK/1    Release: 2.3
  52. C---------------------------------------------------------
  53. C                  MAIN INTEGER STORAGE ARRAYS
  54. C MAXLBG = Maximum number of DO statement labels per routine
  55.         INTEGER MAXLBG
  56.         PARAMETER(MAXLBG=100)
  57.         COMMON / WORKC   /  IABEG(201),  ICRTNG(200), IPCNTG(75),
  58.      *         IRCNTG(75),  ISBEG(201),  ISCNTG(75),  INSTG(250),
  59.      *         KEXECG(75),  LABG(2,MAXLBG), KTOKG(81)
  60.         INTEGER IABEG,ICRTNG,IPCNTG,IRCNTG,ISBEG,ISCNTG,INSTG,
  61.      +          KEXECG,LABG,KTOKG
  62.         SAVE /WORKC/
  63.  
  64.         INTEGER TKNPTH(81),CMTPTH(81),INSPTH(81),
  65.      +          STSPTH(81),TKOPTH(81),CMOPTH(81),
  66.      +          SUMPTH(81),OPTSTR(134),SCRPTH(11),
  67.      +          IODTKN,IODCMT,IODTKO,IODCMO,I
  68.  
  69.         INTEGER GETARG,OPEN,CREATE,ZTKGTI,ZTKPTI
  70.         EXTERNAL GETARG,OPEN,CREATE,ZINIT,ZQUIT,ERROR,CLOSE,ZMESS,
  71.      +           REMOVE,ZTKGTI,ZTKPTI
  72.  
  73.         DATA SCRPTH/97,110,108,115,99,114,46,116,109,
  74.      +112,129/
  75.  
  76.         CALL ZINIT
  77.  
  78.         IF (GETARG(1,TKNPTH,81).EQ.-100) CALL NAMES(1,TKNPTH)
  79.         IF (GETARG(2,CMTPTH,81).EQ.-100) CALL NAMES(2,CMTPTH)
  80.         IF (GETARG(3,INSPTH,81).EQ.-100) CALL NAMES(3,INSPTH)
  81.         IF (GETARG(4,STSPTH,81).EQ.-100) CALL NAMES(4,STSPTH)
  82.         IF (GETARG(5,TKOPTH,81).EQ.-100) CALL NAMES(5,TKOPTH)
  83.         IF (GETARG(6,CMOPTH,81).EQ.-100) CALL NAMES(6,CMOPTH)
  84.         IF (GETARG(7,SUMPTH,81).EQ.-100) CALL NAMES(7,SUMPTH)
  85.         IF (GETARG(8,OPTSTR,134).EQ.-100) CALL NAMES(8,OPTSTR)
  86.  
  87.         IODTKN=OPEN(TKNPTH,0)
  88.         IF (IODTKN.EQ.-1) CALL ERROR('Can''t open token input')
  89.         IODCMT=OPEN(CMTPTH,0)
  90.         IF (IODCMT.EQ.-1) CALL ERROR('Can''t open comment input')
  91.         IODSTS=CREATE(STSPTH,1)
  92.         IF (IODSTS.EQ.-1)
  93.      +      CALL ERROR('Can''t create statement summary file')
  94.         IODTKO=CREATE(TKOPTH,1)
  95.         IF (IODTKO.EQ.-1) CALL ERROR('Can''t create token output')
  96.         IODCMO=CREATE(CMOPTH,1)
  97.         IF (IODCMO.EQ.-1) CALL ERROR('Can''t create comment output')
  98.         IODSCR=CREATE(SCRPTH,2)
  99.         IF (IODSCR.EQ.-1) CALL ERROR('Can''t create scratch output')
  100.  
  101. C Initialise the token input/output streams
  102.  
  103.         TKIDES=ZTKGTI(1,IODTKN,IODCMT)
  104.         TKODES=ZTKPTI(1,IODTKO,IODCMO)
  105.  
  106. C Process user-specified options
  107.  
  108.         CALL DOOPT(OPTSTR)
  109.         DO 100 I=9,10
  110.             IF (GETARG(I,OPTSTR,134).NE.-100) CALL DOOPT(OPTSTR)
  111.  100    CONTINUE
  112.  
  113. C Initialise pre-processor variables
  114.         CALL INITSS
  115.  
  116. C Input source program and perform annotation
  117. C and instrumentation functions at statement level.
  118.         CALL PASS1S
  119.  
  120. C Close input now we have finished with it, to keep the number of files
  121. C simultaneously open as low as possible (not very low!)
  122.         CALL CLOSE(IODTKN)
  123.         CALL CLOSE(IODCMT)
  124.  
  125. C Perform final instrumentation functions at program level
  126.         IODINS=CREATE(INSPTH,1)
  127.         IF (IODINS.EQ.-1)
  128.      +      CALL ERROR('Can''t create instrumented source file')
  129.         CALL PASS2S
  130.  
  131. C Get rid of scratch file
  132.         CALL CLOSE(IODSCR)
  133.         CALL REMOVE(SCRPTH)
  134.  
  135. C Create summary listing
  136.         IODSUM=CREATE(SUMPTH,1)
  137.         IF (IODSUM.EQ.-1) CALL ERROR('Can''t create summary output')
  138.         CALL SUMS(IPCNTG)
  139.  
  140.         IF (IPCNTG(LERRG).EQ.0) THEN
  141.             CALL ZMESS('[ISTAN Normal Termination]',2)
  142.             CALL ZQUIT(-2)
  143.         ELSE
  144.             CALL ZCHOUT('[ISTAN Terminated, ',2)
  145.             CALL ZPTINT(IPCNTG(LERRG),1,2)
  146.             CALL ZMESS(' errors]',2)
  147.             CALL ZQUIT(-1)
  148.         END IF
  149.  
  150.         END
  151. C ----------------------------------------------------------------------
  152. C
  153. C       N A M E S   -   Input missing argument from user
  154. C
  155.  
  156.         SUBROUTINE NAMES(NUMBER,STRING)
  157.         INTEGER NUMBER,STRING(*)
  158.  
  159.         INTEGER I,PROMPT(34,8)
  160.  
  161.         INTEGER ZGTCMD
  162.         EXTERNAL ZPRMPT,ZGTCMD
  163.  
  164. C "Input token stream: "
  165. C "Input comment stream: "
  166. C "Output instrumented source code: "
  167. C "Output statement summary: "
  168. C "Output annotated token stream: "
  169. C "Output annotated comment stream: "
  170. C "Output summary file: "
  171. C "Options: "
  172.  
  173.         DATA (PROMPT(I,1),I=1,21)/73,110,112,117,116,32,116,
  174.      +111,107,101,110,32,115,116,114,101,97,109,58,
  175.      +32,129/,
  176.      +       (PROMPT(I,2),I=1,23)/73,110,112,117,116,32,99,
  177.      +111,109,109,101,110,116,32,115,116,114,101,97,109,
  178.      +58,32,129/,
  179.      +       (PROMPT(I,3),I=1,34)/79,117,116,112,117,116,32,
  180.      +105,110,115,116,114,117,109,101,110,116,101,100,32,
  181.      +115,111,117,114,99,101,32,99,111,100,101,58,32,
  182.      +129/,
  183.      +       (PROMPT(I,4),I=1,27)/79,117,116,112,117,116,32,
  184.      +115,116,97,116,101,109,101,110,116,32,115,117,109,
  185.      +109,97,114,121,58,32,129/,
  186.      +       (PROMPT(I,5),I=1,32)/79,117,116,112,117,116,32,
  187.      +97,110,110,111,116,97,116,101,100,32,116,111,107,
  188.      +101,110,32,115,116,114,101,97,109,58,32,129/,
  189.      +       (PROMPT(I,6),I=1,34)/79,117,116,112,117,116,32,
  190.      +97,110,110,111,116,97,116,101,100,32,99,111,109,
  191.      +109,101,110,116,32,115,116,114,101,97,109,58,32,
  192.      +129/
  193.         DATA (PROMPT(I,7),I=1,22)/79,117,116,112,117,116,32,
  194.      +115,117,109,109,97,114,121,32,102,105,108,101,58,
  195.      +32,129/,
  196.      +       (PROMPT(I,8),I=1,10)/79,112,116,105,111,110,115,
  197.      +58,32,129/
  198.  
  199.         CALL ZPRMPT(PROMPT(1,NUMBER))
  200.         IF (ZGTCMD(STRING,0).EQ.-1) CALL ERROR('ZGTCMD failed')
  201.  
  202.         END
  203. C ----------------------------------------------------------------------
  204. C
  205. C       D O O P T   -   Decode the option string
  206. C
  207.  
  208.         SUBROUTINE DOOPT(OPTSTR)
  209.         INTEGER OPTSTR(134)
  210.  
  211. C---------------------------------------------------------
  212. C    TOOLPACK/1    Release: 2.3
  213. C---------------------------------------------------------
  214. C Filenames
  215.         COMMON/ANFNAM/IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  216.         CHARACTER*81 IHSTFN,OHSTFN,LSTFN,ITRAFN,OTRAFN,RUNFN
  217.         SAVE /ANFNAM/
  218. C---------------------------------------------------------
  219. C    TOOLPACK/1    Release: 2.3
  220. C---------------------------------------------------------
  221. C                  LOGICAL VARIABLES
  222.       COMMON / LOGIC   /    ARITHG,      ASSRTG,      BLKDTG,
  223.      *         CARD1G,      CGOTOG,      ENTRYG,      EXECG,
  224.      *         HISTG,       IEOFG,       IFDOG,       INSRTG,
  225.      *         MAING,       SEGMTG,      STOPG,       TRACEG,
  226.      *         TREEG
  227.       LOGICAL  ARITHG,      ASSRTG,      BLKDTG,      CARD1G,
  228.      *         CGOTOG,      ENTRYG,      EXECG,       HISTG,
  229.      *         IEOFG,       IFDOG,       INSRTG,      MAING,
  230.      *         SEGMTG,      STOPG,       TRACEG,      TREEG
  231.  
  232.         SAVE /LOGIC/
  233.  
  234. C---------------------------------------------------------
  235. C    TOOLPACK/1    Release: 2.3
  236. C---------------------------------------------------------
  237. C Option Settings
  238.         COMMON /OPTSC/ INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,
  239.      +                 MTREQG,TIEG,ITRUNG
  240.  
  241.         INTEGER INHSTG,INTRAG,ITHSTG,ITLSTG,ITTRAG,MCIRCG,MTREQG,
  242.      +          ITRUNG
  243.         LOGICAL TIEG
  244.  
  245.         SAVE /OPTSC/
  246.  
  247. C---------------------------------------------------------
  248. C    TOOLPACK/1    Release: 2.3
  249. C---------------------------------------------------------
  250.         COMMON/ANVNAM/VNAMEG
  251.         CHARACTER*5 VNAMEG
  252.         SAVE/ANVNAM/
  253.  
  254.         INTEGER OPTTBL(63),STRING(134),POINT,PTR
  255.         INTEGER LHS(134),RHS(134),OPTION,OPTARG
  256.         LOGICAL LSTSET,TRISET,TROSET,INIT
  257.  
  258.         SAVE OPTTBL,LSTSET,TRISET,TROSET,INIT
  259.  
  260.         INTEGER GETWRD,ZKWLUK,ZSPLIT,LENGTH
  261.         EXTERNAL GETWRD,ZCHOUT,PUTLIN,ZMESS,ZKWLUK,ZSPLIT,SCOPY,ZITOF,
  262.      +           LENGTH
  263.  
  264.         DATA LSTSET,TRISET,TROSET/3*.FALSE./
  265.         DATA OPTTBL/7,
  266.      +      97,115,115,101,114,116,105,111,110,115,129,
  267.      +      104,105,115,116,111,114,121,129,
  268.      +      108,105,115,116,105,110,103,129,
  269.      +      114,117,110,100,97,116,97,129,
  270.      +      116,105,101,95,99,111,110,102,111,114,
  271.      +109,105,110,103,129,
  272.      +      116,114,97,99,101,129,
  273.      +      118,110,97,109,101,129/
  274.         DATA INIT/.TRUE./
  275.  
  276. C First initialise option values
  277.  
  278.         IF (INIT) THEN
  279.             LSTFN=' '
  280.             IHSTFN=' '
  281.             OHSTFN=' '
  282.             ITRAFN=' '
  283.             OTRAFN=' '
  284.             RUNFN=' '
  285.             ITRUNG=0
  286.             INIT=.FALSE.
  287.         END IF
  288.  
  289.         POINT=1
  290.  
  291.  100    IF (GETWRD(OPTSTR,POINT,STRING).EQ.0) RETURN
  292.         IF (ZSPLIT(STRING,LHS,RHS).NE.-2) THEN
  293.             CALL SCOPY(STRING,1,LHS,1)
  294.             RHS(1)=129
  295.         END IF
  296.         OPTION=ZKWLUK(LHS,OPTTBL)
  297.         IF (OPTION.LE.0) THEN
  298.             IF (OPTION.EQ.0) CALL ZCHOUT('%ISTAN - Ambiguous',1)
  299.             IF (OPTION.EQ.-1)  CALL ZCHOUT('%ISTAN - Unknown',1)
  300.             CALL ZCHOUT(' Option "',1)
  301.             CALL PUTLIN(LHS,1)
  302.             CALL ZMESS('" Ignored',1)
  303.         ELSE IF (OPTION.EQ.1) THEN
  304.             ASSRTG=.TRUE.
  305.         ELSE IF (OPTION.EQ.2) THEN
  306.             HISTG=.TRUE.
  307.             IF (RHS(1).NE.129) THEN
  308.                 PTR=1
  309.                 CALL OPTFN(RHS,PTR,IHSTFN,INHSTG)
  310.                 IF (RHS(PTR).NE.129)
  311.      +              CALL OPTFN(RHS,PTR,OHSTFN,ITHSTG)
  312.             END IF
  313.         ELSE IF (OPTION.EQ.3) THEN
  314.             IF (RHS(1).EQ.129) THEN
  315.                 CALL REMARK(
  316.      +              '%ISTAN - Missing argument to the LISTING option')
  317.             ELSE
  318.                 PTR=1
  319.                 CALL OPTFN(RHS,PTR,LSTFN,ITLSTG)
  320.                 LSTSET=.TRUE.
  321.             END IF
  322.         ELSE IF (OPTION.EQ.4) THEN
  323.             IF (RHS(1).EQ.129) THEN
  324.                 CALL REMARK(
  325.      +              '%ISTAN - Missing argument to the RUNDATA option')
  326.             ELSE
  327.                 PTR=1
  328.                 CALL OPTFN(RHS,PTR,RUNFN,ITRUNG)
  329.                 IF (RHS(PTR).NE.129) THEN
  330.                     ITRUNG=0
  331.                     CALL REMARK(
  332.      +                  '%ISTAN - Invalid argument to RUNDATA option')
  333.                 END IF
  334.             END IF
  335.         ELSE IF (OPTION.EQ.5) THEN
  336.             TIEG=.TRUE.
  337.             IF (RHS(1).NE.129) CALL REMARK(
  338.      +          '%ISTAN - Argument to TIE_CONFORMING option ignored')
  339.             IF (.NOT.LSTSET) ITLSTG=1
  340.             IF (.NOT.TRISET) INTRAG=0
  341.             IF (.NOT.TROSET) ITTRAG=1
  342.         ELSE IF (OPTION.EQ.6) THEN
  343.             TRACEG=.TRUE.
  344.             IF (RHS(1).NE.129) THEN
  345.                 PTR=1
  346.                 CALL OPTFN(RHS,PTR,ITRAFN,INTRAG)
  347.                 TRISET=.TRUE.
  348.                 IF (RHS(PTR).NE.129) THEN
  349.                     CALL OPTFN(RHS,PTR,OTRAFN,ITTRAG)
  350.                     TROSET=.TRUE.
  351.                 END IF
  352.             END IF
  353.         ELSE
  354. C OPTION=7 (VNAME)
  355.             IF (RHS(1).EQ.129) THEN
  356.                 CALL REMARK(
  357.      +              '%ISTAN - Missing argument to the VNAME option')
  358.             ELSE IF (LENGTH(RHS).NE.5) THEN
  359.                 CALL REMARK(
  360.      +          '%ISTAN - The length of the VNAME argument must be 5')
  361.             ELSE
  362.                 CALL ZITOF(RHS,1,5,VNAMEG,.FALSE.)
  363.             END IF
  364.         END IF
  365.         GOTO 100
  366.         END
  367. C ----------------------------------------------------------------------
  368. C
  369. C       O P T F N   -   Process option file names
  370. C
  371.  
  372.         SUBROUTINE OPTFN(STRING,POINT,NAME,UNIT)
  373.         INTEGER STRING(*),POINT,UNIT
  374.         CHARACTER*81 NAME
  375.  
  376.         INTEGER I
  377.  
  378.         INTEGER CTOI
  379.         CHARACTER ZCITOC
  380.         EXTERNAL ZCITOC,SKIPBL,REMARK,CTOI
  381.  
  382.         IF (STRING(POINT).GE.48 .AND. STRING(POINT).LE.57) THEN
  383.             UNIT=CTOI(STRING,POINT)
  384.             CALL SKIPBL(STRING,POINT)
  385.             IF (STRING(POINT).EQ.61) THEN
  386.                 POINT=POINT+1
  387.                 CALL SKIPBL(STRING,POINT)
  388.             ELSE
  389.                 GOTO 666
  390.             END IF
  391.         END IF
  392.         IF (STRING(POINT).EQ.42) THEN
  393.             NAME=''''
  394.             POINT=POINT+1
  395.             CALL SKIPBL(STRING,POINT)
  396.             IF (STRING(POINT).NE.44 .AND. STRING(POINT).NE.129)
  397.      +          CALL REMARK('End of option expected')
  398.         ELSE IF (STRING(POINT).EQ.39) THEN
  399.             I=1
  400.             NAME=' '
  401.  100        NAME(I:I)=ZCITOC(STRING(POINT+I),NAME(I:I))
  402.             I=I+1
  403.             IF (STRING(POINT+I).NE.39 .AND.
  404.      +          STRING(POINT+I).NE.129) GOTO 100
  405.             POINT=POINT+I
  406.             IF (STRING(POINT).EQ.39) POINT=POINT+1
  407.         ELSE
  408.             CALL REMARK('Invalid argument to option')
  409.         END IF
  410.  666    IF (STRING(POINT).EQ.44) POINT=POINT+1
  411.  
  412.         END
  413.